perm filename HOMF4.F4[XX,LCS]1 blob sn#195563 filedate 1976-01-08 generic text, type T, neo UTF8
00200		SUBROUTINE HOMNEW
00400		REAL NWID
00600		INTEGER BSTF,BSTM
00800		COMMON /STF/RSTFAC(-3/4),RSTJ2
01000		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(-3/4),JJ2,POS
01200		COMMON /XRN/RN(4000) /PTR/KWDS(250),ITEM,L,IVVV,IX
01400		COMMON/ALF/I(72),HJG
01600		EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9)),(RD,RN(4000))
01800		1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11)),(J4,JQ(2))
02000		1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5)),(STFDIR,I(2)),(J3,JQ(1))
02200		1,(BSTF,I(9)),(NSTF,I(6)),(NSTM,I(18)),(BSTM,I(22)),(NWID,I(15))
02400		1,(BWID,I(16))
02600	
02800	
03000		DIFF=ABS(STFF(BSTF)-STFF(NSTF))/(7.0*RSTFAC(BSTF))
03200	C  ADD MINI FACTOR LATER
03400	CC	STMRVS=13.71428571*RSTFAC(BSTF)*RSTJ2
03410		STMRVS=13.71428571*RSTJ2
03500	C  RSTJ2=.6 FOR MINI-NOTES AND BEAMS
03600	
03800		S1=BSTF
04000		S2=NSTF
04200	C  FIND NOTES ON EITHER STAFF
04400	
04600		JJ2=ITEM
04800	C  IN CASE NOTHING IS DONE
05000	CC	J=KWDS(J2)
05200	C  ITEM # OF BEAM
05400		RNG1=RN(J2+3)-.1
05600	CC	RNG2=RN(J+6)
05800		R=NWID
06000		IF(BSTM.EQ.NSTM)R=0
06200	10	IF(BSTM)R=-R
06400	C STEMS SAME=NO WIDTH TO BE ADDED
06600		RNG2=RN(I(1)+3)+R
06800		RN(J2+6)=RNG2
07000	C  SETS LEFT SIDE OF BEAM
07200	C  SETS RANGE 
07400	CC	DIS=RNG2-RNG1
07600		H1=AMOD(RN(J2+4),100.0)
07800		H2=RN(J2+5)
08000	CC	HGT=H2-H1
08200	C  BEAM VERT. SPREAD
08400	11	HFAC=(H2-H1)/(RNG2-RNG1)
08600		HQ=H1-RNG1*HFAC
08800	C  STUFF TO DETERMINE HEIGHT AT NOTE'S POINT ALONG BEAM.
08900		RNG2=RNG2+NWID
08950		RDIF=DIFF
08975		IF(BSTM)RDIF=-RDIF
08981		IF(S2.LT.S1)RDIF=-RDIF
08987	C  IF BEAM'S STEM IS UP USE NEG. DIFF.
09000	12	DO 100 K=1,ITEM
09200		L=KWDS(K)
09400		IF(RN(L+1).NE.1)GO TO 100
09600	C  IS IT A NOTE?
09800		S=RN(L+2)
10000		IF(S.NE.S1.AND.S.NE.S2)GO TO 100
10200	C  JUMP IF NOT ON EITHER STAFF
10400		RR=RN(L+3)
10600		IF(RR.LT.RNG1.OR.RR.GT.RNG2)GO TO 100
10800	C  JUMP IF NOT IN RANGE OF BEAM
11000	
11200		RWID=NWID
11400		SWID=BWID
11600	C  THE NOTE WIDTH(HORIZ.) AND BEAM WIDTH(VERT.)
11800		B=AMOD(RN(L+4),100.0)
12000	C  NOTE HEIGHT
12200		NN=0
12400		IF(RN(L+5).LT.20.)NN=-1
12600	13	IF(BSTM.NE.NN)GO TO 51
12800		RWID=0
13000		SWID=0
13200	C IGNORE WIDTHS IF BEAMS GO SAME DIR.
13400	CC	A=H1+HGT*(RN(L+3)+RWID-RNG1)/DIS
13500	51	IF(BSTM)RWID=-RWID
13600		A=HQ+HFAC*(RN(L+3)+RWID)
13800	C  HEIGHT OF BEAM AT NOTE POINT (WHEN STMS DIF DIR. +RWID IN ( )
14000		IF(BSTM.NE.NN)GO TO 1
14200	C  JUMP IF STEMS GO DIFF. DIRECTIONS
14400		R=A-B
14600	C  STEMS UP
14800		IF(BSTM.EQ.0)R=-R
15000	C  STEMS DOWN
15200		IF(S.NE.S1)R=R+RDIF
15400		GO TO 50
15600	
15800	1	R=B-A
16000	C  DIFF STEM DIRS.
16200		IF(J3)GO TO 4
16400	C JUMP IF NOTE STAFF IS BELOW
16600		IF(J3.NE.0)GO TO 5
16800		IF(R.GE.0)GO TO 5
17000	4	R=-R
17200	5	R=DIFF-STMRVS+R+SWID
17400	50	RN(L+8)=R
17600		IF(JJ2.EQ.ITEM)JJ2=K
17700		NN=L+7
17750		IF(RN(NN).NE.0)RN(NN)=RN(NN)-AMOD(RN(NN),10.0)
17760	C  TAKES OFF ANY TAILS
17800	100	CONTINUE
18000		END